home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / aggr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  57.1 KB  |  1,821 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* aggr.c : translation of aggr.stl */
  10.  
  11. #define GEN
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "miscprots.h"
  17. #include "setprots.h"
  18. #include "gutilprots.h"
  19. #include "gnodesprots.h"
  20. #include "gmiscprots.h"
  21. #include "smiscprots.h"
  22. #include "initobjprots.h"
  23. #include "expandprots.h"
  24. #include "aggrprots.h"
  25.  
  26. static int tup_eq(Tuple, Tuple);
  27. static Tuple aggr_choice(Node, Tuple, Symbol);
  28. static int needs_subtype(Node, Node, Symbol);
  29. static Node new_type_choice(Node, Symbol, Tuple);
  30. static Tuple aggr_type(Node, Tuple);
  31. static Tuple same_bounds_check(Symbol, Tuple, Tuple);
  32. static Tuple in_bounds_check(Tuple, Tuple, int *);
  33. static Tuple aggr_eval(Node, Tuple, Tuple, Node, Symbol, int);
  34. static Node new_index_bound_node(Const, int, Symbol);
  35.  
  36. /* changes
  37.  * 13-mar-85    shields
  38.  * change 'index_type' to 'indx_type' since index_type is macro in sem.
  39.  *
  40.  * 18-6-86    ACD
  41.  * changed final loop over checks in 'same_bounds_check' to improve
  42.  * efficiency
  43.  *
  44.  * 19-6-86     ACD
  45.  * changed 'exists' to 'static_index' in 'aggr_eval' to improve clarity
  46.  *
  47.  * 22-6-86     ACD
  48.  * changed aggr_eval to allow for optimization of static and semi-static
  49.  * aggregates.  If the aggregate is static and associations and components
  50.  * are static then the aggregate is 'optable'.  A data segment will
  51.  * be created with the aggregate values in the data stack and will be
  52.  * assigned to the array at run time.  The creation of the stack is done
  53.  * by array_ivalue in expr.c.  aggr_eval unwinds the aggregate and changes
  54.  * it into a positional aggregate passing the correct information to 
  55.  * array_ivalue.  Array_ivalue uses the static_nodes to create the segment
  56.  * and appends additional assignment statements for any non-static components
  57.  * If there is an others clause,
  58.  * then it is used to 'fill-in' the missing associations.
  59.  *
  60.  * 24-6-86     ACD
  61.  * Added code to detect the following flags: static_assoc, array_size,
  62.  * static_component to be used in deciding whether to optimize or not.
  63.  * These are set in aggr_choice, in_bounds_check and check_static_comp
  64.  * (new routine) respectively.  From this information the flag:
  65.  * optable are set.  Ths is passed to aggr_eval
  66.  * to decide the level to optimize in attempt to evalaute a time-space
  67.  */
  68.  
  69. void expand_array_aggregate(Node node)            /*;expand_array_aggregate*/
  70. {
  71.     /*
  72.      *
  73.      *  This procedure normalizes the format of an array aggregate, and
  74.      *  constructs the tree for the multiple range checks that may have
  75.      *  to be performed before constructing the aggregate proper.
  76.      *  The aggregate has the format : [positional_list, named_list, others]
  77.      *
  78.      *  On exit from this procedure, the named_list has been expanded into
  79.      *  code to perform range checks, and code to initialize the array
  80.      *  components. The rules of the language require that this code be in
  81.      *  fact elaborated first, that is to say before the elaboration of any
  82.      *  components (including the positional ones).
  83.      *  The positional part has been expanded to collect static components
  84.      *  and give explicit indication of the index positions.
  85.      *  The following takes place in sequence:
  86.      *
  87.      *    a) expand code to evaluate named choices.
  88.      *    b) obtain all index types.
  89.      *    c) For multidimensional aggregates, verify that bounds of all
  90.      *       subaggregates are the same.
  91.      *    d) Verify that the aggregate bounds are compatible with type of
  92.      *       indices.
  93.      *    e) expand code to evaluate components. For named associations
  94.      *       that are static, it is tempting to elaborate the array here,
  95.      *       in full. This is probably impractical for large arrays. The
  96.      *       current solution is to emit a case statement that assigns to
  97.      *       individual components according to the choices.
  98.      *       In the case of a single named component, a loop is emitted.
  99.      *       The same holds for 'others' choice when present.
  100.      *       This scheme clearly contains much room for optimization.
  101.      *
  102.      */
  103.  
  104.     Symbol    type_name;
  105.     Tuple    index_type_list, base_index_type_list, tup, decl_code, ntup;
  106.     Symbol    comp_type, bt, al, obj_name;
  107.     Tuple    new_subtypes;
  108.     Tuple    index_type_sets;
  109.     Tuple    init_code, new_pos, new_index_type_list, new_nam;
  110.     Node    obj_node, pos_node, nam_node, comp_node, n, lnode;
  111.     Fortup    ft1;
  112.  
  113.     int      optable;
  114.     int      array_size;
  115.  
  116. #ifdef TRACE    
  117.     if (debug_flag)
  118.         gen_trace_node("ARRAY_AGGREGATE", node);
  119. #endif
  120.  
  121.  
  122.     /*
  123.      *  STEP 1
  124.      *     Initialize variables etc.
  125.      */
  126.  
  127.     type_name        = N_TYPE(node);
  128.     index_type_list = index_types(type_name);
  129.     tup = SIGNATURE((Symbol) base_type(type_name));
  130.     base_index_type_list = (Tuple) tup[1];
  131.     comp_type = (Symbol)tup[2];
  132.  
  133.     /*
  134.      * STEP 2
  135.      *    Evaluate all choices first, including choices in subaggregates 
  136.      *    declaring anon subtypes when necessary.  A tuple containing 
  137.      *    these declarations is returned.     
  138.      */
  139.     decl_code = aggr_choice(node, index_type_list, comp_type);
  140.  
  141.     /*
  142.      * STEP 3
  143.      *    Then gather all index subtypes for all dimensions.  Add the
  144.      *    code for the new subtypes created to tuple of declarations
  145.      */
  146.     tup = aggr_type(node, index_type_list);
  147.  
  148.     new_subtypes = (Tuple) tup[1];
  149.     index_type_sets = (Tuple) tup[2];
  150.  
  151.     tup_free(tup); ntup = tup_add(decl_code, new_subtypes);
  152.     tup_free(decl_code); decl_code = ntup; 
  153.     tup_free(new_subtypes); /* free after last use */
  154.  
  155.     /* 
  156.      * STEP 4
  157.      *    Now check that all bounds for each dimension are the same.  If bounds
  158.      *    are dynamic, then a set of run-time checks are returned
  159.      */
  160.     tup = same_bounds_check(type_name, index_type_list, index_type_sets);
  161.     init_code = (Tuple) tup[1];
  162.     new_index_type_list = (Tuple) tup[2];
  163.  
  164.     /*
  165.      * STEP 5
  166.      *   Is unconstrained or indices computed in same_bounds_check differ from
  167.      *   those computed in  aggr_type, then set the type of the aggregate to
  168.      *   the index_types to created in same_bounds_check
  169.      */
  170.     if (!tup_eq(index_type_list , new_index_type_list)
  171.       || is_unconstrained(type_name))  {
  172.         bt = base_type(type_name);
  173.         al = ALIAS(type_name);
  174.         type_name = new_unique_name("type");
  175.         NATURE(type_name) = na_subtype;
  176.         TYPE_OF(type_name) = bt;
  177.         tup = tup_new(2);
  178.         tup[1] = (char *) new_index_type_list;
  179.         tup[2] = (char *) comp_type;
  180.         SIGNATURE(type_name) = tup;
  181.         ALIAS(type_name) = al;
  182.         decl_code=tup_with(decl_code, (char *)new_subtype_decl_node(type_name));
  183.         index_type_list       = new_index_type_list;
  184.         N_TYPE(node)       = type_name;
  185.     }
  186.  
  187.     /*
  188.      * STEP 6
  189.      *    Now test that the index_types computed belong to the base_index_types.
  190.      *    If bounds are dynamic, then run_time checks are performed
  191.      */
  192.     array_size = 1;
  193.     tup = in_bounds_check(index_type_list, base_index_type_list, &array_size);
  194.     ntup = tup_add(init_code, tup);
  195.     tup_free(init_code);
  196.     init_code  = ntup;
  197.     tup_free(tup);
  198.  
  199.     /*
  200.      * STEP 7
  201.      *   Finally, expand assignments to individual components. 
  202.      *   Add to aggregate node the name of the object assigned to it. The 
  203.      *   variable, constant, or temporary to which the aggregate is 
  204.      *   assigned, will be bound to this name subsequently. This name has 
  205.      *   been put in the N_UNQ of the node by the FE. In the case of an 
  206.      *   aggregate appearing as the initial value of an object declaration, 
  207.      *   the name has been changed to the first name of the identifier list.
  208.      */
  209.     obj_name   = N_UNQ(node);
  210.     obj_node   = new_name_node(obj_name);
  211.     if (NATURE(obj_name) == na_void) {
  212.         new_symbol(obj_name, na_obj, N_TYPE(node), (Tuple)0, (Symbol)0);
  213.         /* else another copy of the aggregate was already expanded.
  214.          * this is the case if the aggregate is a default expression used
  215.          * in several calls.
  216.          */
  217.     }
  218.  
  219.     optable = (array_size > 0 && array_size < MAX_STATIC_SIZE
  220.       && !(is_unconstrained(comp_type)));
  221.  
  222.     ntup = tup_add(init_code, aggr_eval(node, new_index_type_list, tup_new(0),
  223.       obj_node, comp_type, optable));
  224.     tup_free(init_code);
  225.     init_code = ntup;
  226.  
  227.     /*
  228.      * STEP 8
  229.      *   Sort the nodes that initialize components into those that are pure- 
  230.      *   ly static and those that require emission of assignment statements.
  231.      */
  232.     new_pos = tup_new(0);
  233.     new_nam = tup_new(0);
  234.     FORTUP(comp_node = (Node), init_code, ft1);
  235.         if (N_KIND(comp_node) == as_static_comp) 
  236.             new_pos = tup_with(new_pos, (char *) comp_node);
  237.         else
  238.             new_nam = tup_with(new_nam, (char *) comp_node);
  239.     ENDFORTUP(ft1);
  240.  
  241.     lnode = N_AST1(node);
  242.     pos_node = N_AST1(lnode);
  243.     nam_node = N_AST2(lnode);
  244.  
  245.     N_LIST(pos_node)       = new_pos;
  246.     N_AST1(pos_node)       = (Node) 0;
  247.     if (N_AST2_DEFINED(N_KIND(pos_node))) N_AST2(pos_node)= (Node) 0;
  248.     if (N_AST3_DEFINED(N_KIND(pos_node))) N_AST3(pos_node)= (Node) 0;
  249.     if (N_AST4_DEFINED(N_KIND(pos_node))) N_AST4(pos_node)= (Node) 0;
  250.  
  251.     N_SIDE(node) = FALSE;
  252.     FORTUP(n = (Node), decl_code, ft1);
  253.         expand(n);
  254.         N_SIDE(node) |= N_SIDE(n);
  255.     ENDFORTUP(ft1);
  256.  
  257.     if (tup_size(new_nam) == 0) {
  258.         N_AST1(lnode) = pos_node;
  259.         N_AST2(lnode) = OPT_NODE;
  260.         N_AST1(node) = lnode;
  261.         N_AST2(node) = obj_node;
  262.         /*N_AST4(node) = (Node) 0; -- need to preserve N_TYPE if defined */
  263.         N_KIND(node) = as_array_ivalue;
  264.     }
  265.     else {
  266.         make_statements_node(nam_node, new_nam);
  267.         expand(nam_node);
  268.         /* insert test below to make sure tree reformatting proper */
  269.         if (! is_aggregate(node)) {/* this check may be redundant */
  270.             printf("aggr: test node_kind %d\n", N_KIND(node));/*DEBUG DS*/
  271.             chaos("aggr bad kind");
  272.         }
  273.         N_AST1(lnode) = pos_node;
  274.         N_AST2(lnode) = nam_node;
  275.         N_AST1(node) = lnode;
  276.         N_AST2(node) = obj_node;
  277.         /* suppress next as need to preserve N_TYPE */
  278.         /*if (N_AST4_DEFINED(N_KIND(node))) N_AST4(node) = (Node) 0;*/
  279.  
  280.     }
  281.     if (tup_size(decl_code) != 0) {
  282.         make_insert_node(node, decl_code, copy_node(node));
  283.     }
  284. }
  285.  
  286. static int tup_eq(Tuple ta, Tuple tb)                                /*;tup_eq*/
  287. {
  288. /* compare two tuples for equality */
  289.     int    i, n;
  290.     n = tup_size(ta);
  291.     if (ta == (Tuple)0 && tb == (Tuple)0) return TRUE;
  292.     if (n != tup_size(tb)) return FALSE;
  293.     for (i = 1; i <= n; i++)
  294.         if (ta[i] != tb[i]) return FALSE;
  295.     return TRUE;
  296. }
  297.  
  298. static Tuple aggr_choice(Node node, Tuple index_type_list_arg, Symbol comp_type)
  299.                                                                 /*;aggr_choice*/
  300. {
  301.     /*
  302.      * First step of array_aggregate evaluation: evaluate all choices, and
  303.      * normalize their format. Create anonymous ranges if dynamic bounds,
  304.      * and emit their declarations.
  305.      *
  306.      * Note: if a subtype is emitted, its elaboration will automatically
  307.      *     check for compatibility with index subtype. If bounds are
  308.      *     static, no subtype is emitted, and check is done here.
  309.      *
  310.      * Node is supposed to be an array aggregate. It may happen to be a
  311.      * string literal, in the case of a multidimensional array type of
  312.      * character component (not an array of strings). In this case, it is
  313.      * transformed into an aggregate.
  314.      */
  315.  
  316.     Tuple    anon_decls, tup, comp_list, index_type_list; /* check that local */
  317.     Symbol    index_t, temp;
  318.     int        nk, c;
  319.     Tuple    str_val;  /* check type of this */
  320.     Node    pos_node, lbd_node, ubd_node, choice, ch_node, comp_ch, v_expr, t;
  321.     Node    nam_node, tnod, choice_node, subtype_node, lnode;
  322.     Const    lbd_val, ubd_val;
  323.     Tuple    pos, nam, constraint, ntup;
  324.     Node    range_node, constraint_node, val_node, comp, assoc;
  325.     Fortup    ft1;
  326.     int        lbd_int, ubd_int;
  327.  
  328. #ifdef TRACE
  329.     if (debug_flag) {
  330.         gen_trace_node("AGGR_CHOICE", node);
  331.         gen_trace_symbols("AGGR_CHOICE arguments", index_type_list_arg);
  332.     }
  333. #endif
  334.     anon_decls = tup_new(0);
  335.     index_type_list = tup_copy(index_type_list_arg); 
  336.     /* since tup_fromb destructive*/
  337.     index_t = (Symbol) tup_fromb(index_type_list);
  338.     nk = N_KIND(node);
  339.  
  340.     /*
  341.      * Case: string_ivalue
  342.      */
  343.     if (nk == as_string_ivalue) {
  344.         str_val = (Tuple) N_VAL(node);
  345.         N_KIND(node) = as_array_aggregate;
  346.         N_VAL (node) = (char *)0;
  347.         if (tup_size(str_val) == 0) {
  348.             /* Must make a named association, because of 4.2(3) */
  349.             pos_node = new_node(as_list);
  350.             N_LIST(pos_node) = tup_new(0);
  351.             lbd_node = new_attribute_node(ATTR_T_FIRST, new_name_node(index_t),
  352.               OPT_NODE, index_t);
  353.             ubd_node = new_attribute_node(ATTR_PRED,
  354.               new_name_node(base_type(index_t)), copy_tree(lbd_node),
  355.               base_type(index_t));
  356.             choice = new_node(as_range);
  357.             N_AST1(choice)      = lbd_node;
  358.             N_AST2(choice)      = ubd_node;
  359.             ch_node      = new_node(as_list);
  360.             N_LIST(ch_node)  = tup_new1((char *) choice);
  361.             v_expr    = new_ivalue_node(int_const(0), comp_type);  /* Why not.. */
  362.             comp_ch      = new_node(as_choice_list);
  363.             N_AST1(comp_ch)      = ch_node;
  364.             N_AST2(comp_ch)      = v_expr;
  365.             nam_node      = new_node(as_list);
  366.             N_LIST(nam_node) = tup_new1((char *) comp_ch);
  367.         }
  368.         else {
  369.             pos_node        = new_node(as_list);
  370.             comp_list        = tup_new(0);
  371.             tup = SIGNATURE(comp_type);
  372.             lbd_node = (Node) tup[2];
  373.             ubd_node = (Node) tup[3];
  374.             lbd_val        = get_ivalue(lbd_node);
  375.             ubd_val        = get_ivalue(ubd_node);
  376.             if (lbd_val->const_kind != CONST_OM) 
  377.                 lbd_int = get_ivalue_int(lbd_node);
  378.             if (ubd_val->const_kind != CONST_OM) 
  379.                 ubd_int = get_ivalue_int(ubd_node);
  380.             FORTUP(c = (int), str_val, ft1);
  381.                 if ((lbd_val->const_kind != CONST_OM 
  382.                   && ubd_val->const_kind != CONST_OM)
  383.                   && c >= lbd_int && c <= ubd_int) {
  384.                     comp_list  = tup_with(comp_list, 
  385.                       (char *) new_ivalue_node(int_const(c), comp_type));
  386.                 }
  387.                 else {
  388.                     comp_list = tup_with(comp_list,
  389.                       (char *) new_qual_range_node(new_ivalue_node(int_const(c),
  390.                        symbol_character), comp_type));
  391.                 }
  392.             ENDFORTUP(ft1);
  393.             N_LIST(pos_node) = comp_list;
  394.             nam_node      = new_node(as_list);
  395.             N_LIST(nam_node) = tup_new(0);
  396.         }
  397.         lnode = node_new(as_aggregate_list);
  398.         N_AST1(lnode) = pos_node;
  399.         N_AST2(lnode) = nam_node;
  400.         N_AST1(node) = lnode;
  401.         N_AST2(node) = OPT_NODE;
  402.     }
  403.     else if (!(nk == as_array_aggregate) && !(nk == as_array_ivalue)) {
  404.         chaos("compiler error");
  405.         compiler_error_k("Illegal array aggregate subcomponent: ", node );
  406.     }
  407.  
  408.     /*
  409.      * STEP 2.
  410.      *    Process the aggregate choices
  411.      */
  412.     pos_node = N_AST1(N_AST1(node));
  413.     nam_node = N_AST2(N_AST1(node));
  414.     pos        = N_LIST(pos_node);
  415.     nam        = N_LIST(nam_node);
  416.  
  417.     if (tup_size(pos) == 0  && tup_size(nam) == 1) {
  418.         /*
  419.          * Case: single named association
  420.          *      only case that can be non-static. 
  421.          *      Possible error: #choice_list may be > 1. Front-end must unfold. 
  422.          */
  423.         tnod = (Node) nam[1];
  424.         choice_node = N_AST1(tnod);
  425.         v_expr = N_AST2(tnod);
  426.         tup = N_LIST(choice_node);
  427.         choice = (Node) tup[1];
  428.  
  429.         expand(choice);
  430.         N_SIDE(node) = N_SIDE(choice);
  431.  
  432.         nk = N_KIND(choice);
  433.         /*
  434.          * Subcase: as_range for single named choice
  435.          */
  436.         if (nk == as_range) {
  437.             lbd_node = N_AST1(choice);
  438.             ubd_node = N_AST2(choice);
  439.               if (needs_subtype(lbd_node, ubd_node, index_t)) {
  440.                 /* Build anonymous subtype for choice described by non- */
  441.                 /* static range. */
  442.                 constraint = constraint_new(co_range);
  443.                 constraint[2] = (char *) lbd_node;
  444.                 constraint[3] = (char *) ubd_node;
  445.                 t = new_type_choice(choice, index_t, constraint);
  446.                 anon_decls = tup_with(anon_decls, (char *)  t);
  447.             }
  448.         }
  449.  
  450.         /*
  451.          * Subcase: as_range_choice for single named choice
  452.          */
  453.         else if (nk == as_range_choice) {
  454.             subtype_node = N_AST1(choice);
  455.             range_node = N_AST2(subtype_node);
  456.             lbd_node = N_AST1(range_node);
  457.             ubd_node = N_AST2(range_node);
  458.  
  459.             if (needs_subtype(lbd_node, ubd_node, index_t)) {
  460.                 /* Build anon subtype for choice described by non-sttc range.*/
  461.                 constraint = constraint_new(co_range);
  462.                 constraint[2] = (char *) lbd_node;
  463.                 constraint[3] = (char *) ubd_node;
  464.                 t = new_type_choice(choice, index_t, constraint);
  465.                 anon_decls = tup_with(anon_decls, (char *)  t);
  466.             }
  467.             else {
  468.                 copy_attributes(range_node, choice);
  469.             }
  470.         }
  471.         /*
  472.          * Subcase: as_subtype for single named choice
  473.          */
  474.         else if (nk == as_subtype) {
  475.             /* promote to anonymous subtype also */
  476.             /*bt = (Node) N_AST2(choice);*/
  477.             constraint_node = (Node) N_AST2(choice);
  478.             lbd_node = N_AST1(constraint_node);
  479.             ubd_node = N_AST2(constraint_node);
  480.             /*    constraint = [N_UNQ(constraint_node), lbd_node, ubd_node];
  481.              * The above line from SETL version is wrong as first component
  482.              * of tuple should be constraint kind. For now we issue warning
  483.              * and make in co_range.        ds  7-10-85
  484.              */
  485. #ifdef DEBUG
  486.             printf("warning - review constraint settingin aggr.c\n");
  487. #endif
  488.             constraint = constraint_new(co_range);
  489.             /*constraint[1] = (char *) N_UNQ(constraint_node);*/
  490.             constraint[2] = (char *) lbd_node;
  491.             constraint[3] = (char *) ubd_node;
  492.             t = new_type_choice(choice, index_t, constraint);
  493.             anon_decls = tup_with(anon_decls, (char *) t);
  494.         } 
  495.         /*
  496.          * Subcase: as_simple_choice for single named choice
  497.          *     if it is a non-static single choice given by an expression then
  498.          *     transform into a range of size 1.  If it has a side-effect
  499.          *     (e.g. f(x) => 3) then introduce anon subtype to prevent double
  500.          *     eval.
  501.          */
  502.         else if (nk == as_simple_choice) {
  503.             val_node = N_AST1(choice);
  504.             if (!is_ivalue(val_node)) {
  505.                 if (!N_SIDE(choice)) {
  506.                     constraint = constraint_new(co_range);
  507.                     constraint[2] = (char *) choice;
  508.                     constraint[3] = (char *) choice;
  509.                 }
  510.                 else {
  511.                     temp = new_unique_name("single");
  512.                     new_symbol(temp, na_obj, index_t, (Tuple)0, (Symbol)0);
  513.                     anon_decls = tup_with(anon_decls, 
  514.                       (char *) new_var_node(temp, index_t, val_node));
  515.                     tup = constraint_new(co_range);
  516.                     tup[2] = (char *) new_name_node(temp);
  517.                     tup[3] = (char *) new_name_node(temp);
  518.                     constraint    = tup;
  519.                 }
  520.                 t = new_type_choice(choice, index_t, constraint);
  521.                 anon_decls = tup_with(anon_decls, (char *)  t);
  522.             }
  523.         }
  524.         /*
  525.          * Subcase: error case for single named choice
  526.          */
  527.         else if (nk != as_simple_name) {
  528.             chaos("compiler error -unknown choice in array aggr.");
  529.             compiler_error_k("Unknown choice in array aggregate: ", choice);
  530.         }
  531.     }
  532.     /*
  533.      * Case:  Anything other that a single named association
  534.      */
  535.     else {
  536.         N_SIDE(node) = FALSE;
  537.     }
  538.  
  539.     /*
  540.      * STEP 3.
  541.      *   process remaining dimensions by recursing on remaining indices. Each 
  542.      *   vexpr is an aggregate.  Iterate over position and named list  
  543.      *   concatenating the anon type declaration
  544.      */
  545.     if (tup_size(index_type_list) != 0) {
  546.         FORTUP(comp = (Node), pos, ft1);
  547.             tup = aggr_choice(comp, index_type_list, comp_type);
  548.               ntup = tup_add(anon_decls, tup);
  549.             tup_free(anon_decls); anon_decls = ntup; tup_free(tup);
  550.             N_SIDE(node) |= N_SIDE(comp);
  551.         ENDFORTUP(ft1);
  552.  
  553.         FORTUP(assoc = (Node), nam, ft1);
  554.             v_expr = N_AST2(assoc);
  555.             tup = aggr_choice(v_expr, index_type_list, comp_type);
  556.               ntup = tup_add(anon_decls, tup);
  557.             tup_free(anon_decls); anon_decls = ntup; tup_free(tup);
  558.         ENDFORTUP(ft1);
  559.     }
  560.     return anon_decls;
  561. }
  562.  
  563. static int needs_subtype(Node lbd_node, Node ubd_node, Symbol index_t)
  564.                                                             /*;needs_subtype*/
  565. {
  566.     Tuple    tup;
  567.     Const    lbd_val, ubd_val;
  568.     Node     typ_lbd, typ_ubd;
  569.  
  570.     if ((!is_ivalue(lbd_node)) || (!is_ivalue(ubd_node))
  571.       || (!is_static_type(index_t))) {
  572.         return TRUE;
  573.     }
  574.     else {
  575.         /* May need to force CONSTRAINT_ERROR if bnds statically out of bnds */
  576.  
  577.         lbd_val = get_ivalue(lbd_node);
  578.         ubd_val = get_ivalue(ubd_node);
  579.         if (INTV(lbd_val) <= INTV(ubd_val)) { /* No qual on null ranges */
  580.             tup = SIGNATURE(index_t);
  581.             typ_lbd = (Node) tup[2];
  582.             typ_ubd = (Node) tup[3];
  583.     
  584.             /* TBSL: may need to check these values are integers */
  585.  
  586.             if (get_ivalue_int(lbd_node) < get_ivalue_int(typ_lbd)
  587.               || get_ivalue_int(ubd_node) > get_ivalue_int(typ_ubd)) {
  588.                   USER_WARNING("Choice in aggregate will raise ",
  589.                   "CONSTRAINT_ERROR");
  590.                 return TRUE;
  591.             }
  592.         }
  593.      }
  594.     return FALSE;
  595. }
  596.  
  597. static Node new_type_choice(Node choice_node, Symbol index_t, Tuple constraint)
  598.                                                         /*;new_type_choice*/
  599. {
  600.     /*
  601.      * create anonymous subtype for dynamic range in choice, and return code
  602.      * for creation of this anonymous subtype. Update the choice to carry
  603.      * a type name.
  604.      * Note: parent type must be the base type in order to avoid checking for
  605.      * constraint_error now (must be done after ALL choices are elaborated).
  606.      */
  607.  
  608.     Symbol    temp;
  609.  
  610.     temp = new_unique_name("choice");
  611.     new_symbol(temp, na_subtype, base_type(index_t),constraint, ALIAS(index_t));
  612.     make_name_node(choice_node, temp);
  613.     return new_subtype_decl_node(temp);
  614. }
  615.  
  616. static Tuple aggr_type(Node node, Tuple index_type_list_arg)    /*;aggr_type*/
  617. {
  618.     /*
  619.      * Collect the index types given in the aggregate itself. These are used
  620.      * to build the actual aggregate  subtype in the case  where the context
  621.      * type is unconstrained.
  622.      * The result is a pair; the first component is a tuple, the second
  623.      * is  a tuple of sets of symbols.
  624.      */
  625.  
  626.     Tuple    index_type_list;
  627.     Node    pos_node, nam_node, others_node, assoc, choice_list_node;
  628.     Tuple    all_choices, all_vexpr, nam, pos, choice_list, code;
  629.     Fortup    ft1;
  630.     Node    vexpr, choice, lbd_node, ubd_node, first_node;
  631.     int        err, static_bounds, nk, lw_val, hg_val;
  632.     int        high_bound, low_bound, i;
  633.     Symbol    t, actual_index, assumed_index;
  634.     Tuple    tup, sig, other_indices, down_subt, down_indices, ntup;
  635.     Const    low, hi, lw, hg;
  636.     int        low_bound_defined = FALSE, high_bound_defined = FALSE;
  637.     int        low_int, hi_int;
  638.     Set        aset, tset;
  639.  
  640.     /* index_type_list in SETL version becomes index_type_list_arg in
  641.      * C version to permit copy here to avoid problems that would
  642.      * result from destructive use made of index_type_list later on.
  643.      */
  644.     /*
  645.      * STEP 1.
  646.      *   Initialize variables 
  647.      */
  648.     index_type_list = tup_copy(index_type_list_arg);
  649.     sig = (Tuple) 0;
  650. #ifdef TRACE
  651.     if (debug_flag) {
  652.         gen_trace_node("AGGR_TYPE AST1 (pos)", N_AST1(N_AST1(node)));
  653.         gen_trace_node("AGGR_TYPE AST2 (nam)", N_AST2(N_AST1(node)));
  654.         gen_trace_node("AGGR_TYPE AST3 (others)", N_AST2(node));
  655.         gen_trace_symbols("AGGR_TYPE", index_type_list);
  656.     }
  657. #endif
  658.  
  659.     assumed_index = (Symbol) tup_fromb(index_type_list);
  660.  
  661.     pos_node = N_AST1(N_AST1(node));
  662.     nam_node = N_AST2(N_AST1(node));
  663.     others_node = N_AST2(node);
  664.     all_choices = tup_new(0);
  665.     all_vexpr   = tup_new(0);
  666.     nam        = N_LIST(nam_node);
  667.     pos        = N_LIST(pos_node);
  668.  
  669.     /*
  670.      * STEP 2.
  671.      *   Process aggregate to get actual index.  In addition, collect a
  672.      *   tuple of the v_expressions
  673.      */
  674.  
  675.     /* Case 1:  others choice present    */
  676.     /*      can only be present if type is constrained. */
  677.  
  678.     if (others_node != OPT_NODE) {
  679.         all_vexpr = tup_with(all_vexpr, (char *) others_node);
  680.         actual_index = assumed_index;
  681.     }
  682.     /*
  683.      * Case 2:  named associations and not others  
  684.      *    - Collect all ranges present in named associations. 
  685.      *    - Iterate over all bounds on this dimension, finding smallest and
  686.      *    - largest
  687.      */
  688.     else if (tup_size(nam) != 0) {
  689.         FORTUP(assoc = (Node), nam, ft1);
  690.             choice_list_node = N_AST1(assoc);
  691.             vexpr = N_AST2(assoc);
  692.             choice_list = N_LIST(choice_list_node);
  693.             if (vexpr != (Node)0) {      /* absent if static null aggregate */
  694.                 all_vexpr = tup_with(all_vexpr, (char *)  vexpr);
  695.             }
  696.             ntup = tup_add(all_choices, choice_list);
  697.             tup_free(all_choices); all_choices = ntup;
  698.         ENDFORTUP(ft1);
  699.  
  700.         static_bounds = TRUE;
  701.         err = FALSE;
  702.         FORTUP(choice = (Node), all_choices, ft1);
  703.             nk = N_KIND(choice);
  704.             if (nk == as_simple_name) {
  705.                 t = N_UNQ(choice);
  706.                 if (NATURE(t) == na_type
  707.                   || NATURE(t) == na_subtype || NATURE(t) == na_enum) {
  708.                     tup = SIGNATURE(t);
  709.                     lbd_node = (Node) tup[2];
  710.                     ubd_node = (Node) tup[3];
  711.  
  712.                     lw = get_ivalue(lbd_node); 
  713.                     hg = get_ivalue(ubd_node);
  714.                     if  (lw->const_kind != CONST_OM
  715.                       && hg->const_kind != CONST_OM) {
  716.                         lw_val = get_ivalue_int(lbd_node);
  717.                         hg_val = get_ivalue_int(ubd_node);
  718.                     }
  719.                     else {
  720.                           actual_index    = N_UNQ(choice);
  721.                           static_bounds = FALSE;
  722.                     }
  723.                 }
  724.                 else {
  725.                     err = TRUE;
  726.                     compiler_error("Simple name not type in aggr. choice");
  727.                 }
  728.             }
  729.             else if (nk == as_range) {
  730.                 /* We know from previous pass that it is static. */
  731.                 lbd_node = N_AST1(choice);
  732.                 ubd_node = N_AST2(choice);
  733.                 lw_val = get_ivalue_int(lbd_node);
  734.                 hg_val = get_ivalue_int(ubd_node);
  735.             }
  736.             else if(nk == as_simple_choice) {
  737.                 lbd_node = N_AST1(choice);
  738.                 lw_val = get_ivalue_int(lbd_node);
  739.                 hg_val = lw_val;
  740.               }
  741.             else if (nk == as_ivalue || nk == as_int_literal) {
  742.                 lw_val = get_ivalue_int(choice);
  743.                 hg_val = lw_val;
  744.             }
  745.             else {
  746.                 err = TRUE;
  747.                 compiler_error_k("Unknown choice in aggr_type: ", choice);
  748.               }
  749.  
  750.               if (!err && static_bounds) {
  751.                 if (!low_bound_defined) {
  752.                     low_bound_defined = TRUE;
  753.                     low_bound = lw_val;
  754.                  }
  755.                 if (low_bound > lw_val) low_bound = lw_val;
  756.                 if (!high_bound_defined) {
  757.                     high_bound_defined = TRUE;
  758.                     high_bound = hg_val;
  759.                 }
  760.                 if (high_bound < hg_val) high_bound = hg_val;
  761.             }
  762.         ENDFORTUP(ft1);
  763.  
  764.         if (static_bounds) {
  765.             sig = constraint_new(co_range);
  766.             sig[2] = (char *) new_ivalue_node(int_const(low_bound),  
  767.               assumed_index);
  768.             sig [3] = (char *)new_ivalue_node(int_const(high_bound), 
  769.               assumed_index);
  770.         }
  771.     }
  772.  
  773.     /* Case 3:  positional associations and no others  */
  774.  
  775.     else    {     /* nam = [], positional associations, no others. */
  776.         ntup = tup_add(all_vexpr, pos); 
  777.         tup_free(all_vexpr); all_vexpr = ntup;
  778.         tup = SIGNATURE(assumed_index);
  779.         lbd_node = (Node) tup[2];
  780.         ubd_node = (Node) tup[3];
  781.  
  782.         low = get_ivalue(lbd_node); 
  783.         if (low->const_kind != CONST_OM) {
  784.               low_int = get_ivalue_int(lbd_node);
  785.             hi = get_ivalue(ubd_node);
  786.             if (hi->const_kind != CONST_OM)
  787.                 hi_int = get_ivalue_int(ubd_node);
  788.             if (hi->const_kind != CONST_OM 
  789.               && (tup_size(pos) == hi_int - low_int + 1)) {
  790.                 /* actual bounds match index subtype. */
  791.                 actual_index = assumed_index;
  792.             }
  793.             else { /* Upper bound determined from number of components. */
  794.                 sig = constraint_new(co_range);
  795.                 sig[2] = (char *) lbd_node;
  796.                 sig[3] =
  797.                    (char *)new_ivalue_node(int_const(tup_size(pos)-1 + low_int),
  798.                    assumed_index);
  799.             }
  800.         }
  801.         else {  /* Non-static low bound. */
  802.             first_node = new_attribute_node(ATTR_T_FIRST,
  803.               new_name_node(assumed_index), OPT_NODE, assumed_index);
  804.             sig = constraint_new(co_range);
  805.             sig[2] = (char *) first_node;
  806.             sig[3] = (char *) new_binop_node(symbol_addi,
  807.              new_ivalue_node(int_const(tup_size(pos) - 1), assumed_index),
  808.              copy_tree(first_node), assumed_index);
  809.         }
  810.     }
  811.     /* 
  812.      * STEP 3
  813.      *     Build an anonymous subtype with bounds if one has been detected
  814.      */
  815.     if (sig != (Tuple)0) {
  816.         actual_index = new_unique_name("choice");
  817.         new_symbol(actual_index, na_subtype, base_type(assumed_index),
  818.           sig, ALIAS(assumed_index));
  819.         code = tup_new1((char *) new_subtype_decl_node(actual_index));
  820.     }
  821.     else {
  822.         code = tup_new(0);
  823.     }
  824.  
  825.     /*
  826.      * STEP 4.
  827.      *    In the multidimensional case,  recurse over inner aggregates. For 
  828.      *    each, collect the set of bounds that it provides on each dimension.
  829.      */
  830.  
  831.     if (tup_size(index_type_list) == 0) { /* reached last level */
  832.         tup = tup_new(2);
  833.         tup[1] = (char *) code;
  834.         tup[2] = (char *) tup_new1((char *) set_new1((char *) actual_index));
  835.         tup_free(index_type_list);
  836.         return tup;
  837.     }
  838.     else {
  839.         other_indices = tup_new(tup_size(index_type_list));
  840.         for (i = 1; i <= tup_size(index_type_list); i++)
  841.             other_indices[i] = (char *) set_new(0);
  842.         FORTUP(vexpr = (Node), all_vexpr, ft1);
  843.             tup =  aggr_type(vexpr, index_type_list);
  844.               down_subt = (Tuple) tup[1];
  845.             down_indices = (Tuple) tup[2];
  846.             tup_free(tup);
  847.             ntup = tup_add(code, down_subt);
  848.             tup_free(code); code = ntup; 
  849.             for (i = 1; i <= tup_size(index_type_list); i++) {
  850.                 tset = (Set) other_indices[i];
  851.                 other_indices[i]=(char *) set_union(tset, (Set)down_indices[i]);
  852.                 set_free(tset);
  853.               }
  854.         ENDFORTUP(ft1);
  855.  
  856.         /* TBSL (after acvc): some dead sets can probably be freed here */
  857.         tup = tup_new(2);
  858.         tup[1] = (char *) code;
  859.         aset = set_new(1);
  860.         aset = set_with(aset, (char *) actual_index);
  861.         tup[2] = (char *) tup_add(tup_new1((char *) aset), other_indices);
  862.         tup_free(index_type_list);
  863.         return tup;
  864.         /*      return [code, [{actual_index}] + other_indices];*/
  865.     }
  866. }
  867.  
  868. static Tuple same_bounds_check(Symbol type_name, Tuple index_type_list,
  869.   Tuple index_type_sets)                                /*;same_bounds_check*/
  870. {
  871.     /*  This function checks that the set of index_types computed for each
  872.      *  dimension.  It compares these to an 'assumed_type' - either the
  873.      *  index-type for that dimension or if it this type is not a member
  874.      *  of the set of index_types derived, then it selects an arbitrary
  875.      *  element in the set.
  876.      */
  877.  
  878.     Tuple    new_index_type_list, check_list, tup, code;
  879.     int        i;
  880.     Symbol    assumed_type, indx_type;
  881.     Node    low, high, l1, l2, h1, h2, cond, cond_list, high2, low2;
  882.     Forset    fs1;
  883.     Fortup    ft1;
  884.     Const    lw, hg, hg2, lw2;
  885.     Set        index_set;
  886.  
  887.  
  888.     new_index_type_list = tup_new(0);
  889.     check_list         = tup_new(0);
  890.     code         = tup_new(0);
  891.  
  892.     /*
  893.      * STEP 1
  894.      *  Process the bounds for each dimension
  895.      */
  896.     for (i = 1; i <= tup_size(index_type_list); i++) {
  897.         /*
  898.          * STEP 1a
  899.          *    Set of bounds suggested by subaggregates on this dimension.
  900.          *    This set is produced by 'aggr_type'.  An assumed_type is
  901.          *    selected: if it is a constrained array: use given index otherwise
  902.          *    pick arbitrary index from actual bounds. 
  903.          */
  904.         index_set = (Set) index_type_sets[i];
  905.         if (set_mem(index_type_list[i], index_set)) {
  906.             assumed_type  = (Symbol) index_type_list[i];
  907.               index_set = set_less(index_set , (char *) assumed_type);
  908.         }
  909.         else assumed_type = (Symbol) set_from(index_set);
  910.  
  911.         new_index_type_list = tup_with(new_index_type_list,
  912.           (char *) assumed_type);
  913.         tup = SIGNATURE(assumed_type);
  914.         low = (Node) tup[2];
  915.         high = (Node) tup[3];
  916.         lw = get_ivalue(low);
  917.         hg = get_ivalue(high);
  918.  
  919.         /*
  920.          * STEP 1b
  921.          *   Compare the bounds of the assumed type to the index_type and
  922.          *   generate dynamic checks if necessary
  923.          */
  924.  
  925.         FORSET(indx_type = (Symbol), index_set, fs1);
  926.             tup = SIGNATURE(indx_type);
  927.             low2 = (Node) tup[2];
  928.             high2 = (Node) tup[3];
  929.             lw2 = get_ivalue(low2);
  930.             hg2 = get_ivalue(high2);
  931.  
  932.             if (lw->const_kind != CONST_OM && lw2->const_kind != CONST_OM) {
  933.                 if (const_ne(lw, lw2)) {
  934.                     code = tup_with(code, (char *)
  935.                       new_raise_node(symbol_constraint_error));
  936.                     USER_WARNING("Evaluation of aggregate will raise",
  937.                       " CONSTRAINT_ERROR");
  938.                 }
  939.               }
  940.             else { /* code to check dynamically the equality of lower bounds. */
  941.                 l1 = new_index_bound_node(lw,  ATTR_T_FIRST, assumed_type);
  942.                 l2 = new_index_bound_node(lw2, ATTR_T_FIRST, indx_type);
  943.                 check_list = tup_with(check_list,
  944.                   (char *) new_binop_node(symbol_ne, l1, l2, symbol_boolean));
  945.             }
  946.  
  947.             if (hg->const_kind != CONST_OM && hg2->const_kind != CONST_OM) {
  948.                 if (const_ne(hg , hg2)) {
  949.                     code = tup_with(code, (char *)
  950.                       new_raise_node(symbol_constraint_error));
  951.                     USER_WARNING("Evaluation of aggregate will raise",
  952.                       " CONSTRAINT_ERROR");
  953.                 }
  954.               }
  955.             else { /* code to check dynamically the equality of upper bounds. */
  956.                 h1 = new_index_bound_node(hg,  ATTR_T_LAST, assumed_type);
  957.                 h2 = new_index_bound_node(hg2, ATTR_T_LAST, indx_type);
  958.                 check_list = tup_with(check_list, (char *)
  959.                   new_binop_node(symbol_ne, h1, h2, symbol_boolean));
  960.             }
  961.         ENDFORSET(fs1); /* end loop */
  962.     }
  963.  
  964.     /*
  965.      * STEP 2
  966.      *   Create an expression to perform all of dynamic checks at run time
  967.      *   for all dimensions at one time
  968.      */
  969.     if (tup_size(check_list) != 0) {
  970.         cond_list = (Node) tup_frome(check_list);
  971.         FORTUP(cond = (Node), check_list, ft1); 
  972.             cond_list = new_binop_node(symbol_orelse, cond, cond_list,
  973.               symbol_boolean);
  974.         ENDFORTUP(ft1); 
  975.         tup_free(check_list);
  976.         code = tup_with(code, (char *)  new_simple_if_node(cond_list,
  977.           new_raise_node(symbol_constraint_error), OPT_NODE));
  978.     }
  979.     tup = tup_new(2);
  980.     tup[1] = (char *) code;
  981.     tup[2] = (char *) new_index_type_list;
  982.     return tup;
  983. }
  984.  
  985. static Tuple in_bounds_check(Tuple index_type_list, Tuple base_index_type_list,
  986.   int *array_size)                                        /*;in_bounds_check*/
  987. {
  988.     /* Emit code to check that bounds of aggregate belong to the index
  989.      * subtypes.  This compares the index types to the base index types
  990.      * Note: NO check is made that the aggregate is not (globally) null
  991.      *     (according to LMC decision).
  992.      *TBSL: Simpler code could be generated by using qual_sub on index types.
  993.      */
  994.  
  995.     Tuple    code, tup;
  996.     int        i;
  997.     Symbol    index_t, base_index_t;
  998.     Node    lw, hg, bl, bh;
  999.     Const    bl_val, bh_val, lw_val, hg_val;
  1000.     code = tup_new(0);
  1001.  
  1002.     for (i = 1; i <= tup_size(base_index_type_list); i++) {
  1003.         index_t       = (Symbol) index_type_list[i];
  1004.         base_index_t = (Symbol) base_index_type_list[i];
  1005.         tup = SIGNATURE(index_t);
  1006.         lw = (Node) tup[2]; 
  1007.         hg = (Node) tup[3];
  1008.         tup = SIGNATURE(base_index_t);
  1009.         bl = (Node) tup[2]; bh = (Node) tup[3];
  1010.         lw_val = get_ivalue(lw); hg_val = get_ivalue(hg);
  1011.         bl_val = get_ivalue(bl); bh_val = get_ivalue(bh);
  1012.         if  (bl_val->const_kind != CONST_OM
  1013.           && bh_val->const_kind != CONST_OM
  1014.           && lw_val->const_kind != CONST_OM
  1015.           && hg_val->const_kind != CONST_OM ) {
  1016.             if ((get_ivalue_int(bl) < get_ivalue_int(bh)
  1017.               && get_ivalue_int(lw) < get_ivalue_int(hg))) { /*Non null ranges*/
  1018.                 if  (((get_ivalue_int(bl) > get_ivalue_int(lw)) 
  1019.                   ||  (get_ivalue_int(bh) < get_ivalue_int(hg)))) {
  1020.                     /* Bounds outside of index type. */
  1021.                        code = tup_with(code, (char *) 
  1022.                     new_raise_node(symbol_constraint_error));
  1023.                     USER_WARNING("Incompatible bounds in aggregate will raise",
  1024.                       " CONSTRAINT_ERROR");
  1025.                     *array_size = 0;
  1026.                        break;          /* No need to check the rest... */
  1027.                 }
  1028.                 else
  1029.                     *array_size *= (get_ivalue_int(hg)-get_ivalue_int(lw)) + 1;
  1030.             }
  1031.             else *array_size = 0;
  1032.         }
  1033.         else *array_size = 0;
  1034.     }
  1035.     return code;
  1036. }
  1037.  
  1038. static Tuple aggr_eval(Node aggr, Tuple index_type_list_arg,
  1039.   Tuple subscript_list, Node obj_node, Symbol comp_type, int optable)
  1040.                                                                 /*;aggr_eval*/
  1041. {
  1042.     /*
  1043.      * Expand code to assign to each component of the aggregate.
  1044.      * A special format is used to mark components whose index positions
  1045.      * are static. A case statement is used for the rest.
  1046.      */
  1047.  
  1048.     Tuple    code, pos, nam, tup, comp_list, expr_list, case_list, ncode, stup;
  1049.     int        save_side_value, static_index, index, lw_int, hg_int;
  1050.     Node    post_expr, s, stat_node, dyn_node, nam_node, new_case, lhs;
  1051.     Node    init_node, pos_node, others_node, low, high, low_node, subscript;
  1052.     Node     v_expr_save, choice, lbd_node, ubd_node, static_node; 
  1053.     Fortup    ft1, ft2;
  1054.     Symbol    temp, p, index_t, loop_var, loop_range;
  1055.     Const    lw;
  1056.     Node    v_expr, hg, loop_var_node, range_node, iter, iter_node;
  1057.     Node    choice_list_node, assoc, body_node, var_node, list_node;
  1058.     Node    cases, case_body, case_expr;
  1059.     Tuple    index_type_list;
  1060.     int      lbd_index_t, ubd_index_t, i, nk, lw_val, hg_val;
  1061.     
  1062. #ifdef TRACE
  1063.     if (debug_flag) 
  1064.         gen_trace_symbols("AGGR_EVAL", index_type_list_arg);
  1065. #endif
  1066.  
  1067.     if (tup_size(index_type_list_arg) == 0) {
  1068.         /*
  1069.          * CASE 1: component level
  1070.          *     using index_type_list_arg  we decide we have reached the
  1071.          *     component level (and can therfore produce the final code).
  1072.          *     Assign to the given index position.  Expand component and merge
  1073.          *     pre-statements (in order to diagnose more ivalues)
  1074.          */
  1075.         expand(aggr);
  1076.         static_index = TRUE;
  1077.         code = tup_new(0);
  1078.         save_side_value = N_SIDE(aggr);
  1079.         while (N_KIND(aggr) == as_insert) {
  1080.             /* static_index = FALSE; */
  1081.             static_index = FALSE;
  1082.             ncode = tup_add(code, N_LIST(aggr));
  1083.             tup_free(code); code = ncode;
  1084.             post_expr = N_AST1(aggr);
  1085.             copy_attributes(post_expr, aggr);
  1086.         }
  1087.         N_SIDE(aggr) = save_side_value;
  1088.  
  1089.         /*
  1090.          * STEP 1
  1091.          *  See if the indices are all static 
  1092.          */
  1093.         FORTUP(s = (Node), subscript_list, ft1);
  1094.             if (!is_ivalue(s)) {
  1095.                 static_index = FALSE;
  1096.                 break;
  1097.             }
  1098.         ENDFORTUP(ft1);
  1099.  
  1100.         /* 
  1101.          * STEP 2
  1102.          *   propogate indexing of components.  This consists of three cases
  1103.          *    1.  static indices and an aggregate component
  1104.          *    2.  static indices and a static conponent
  1105.          *    3.  non-static indices -or- non-static component
  1106.          */
  1107.  
  1108.         nk = N_KIND(aggr);
  1109.         if (static_index && is_aggregate(aggr)) {
  1110.             stat_node = N_AST1(N_AST1(aggr));
  1111.             dyn_node = N_AST2(N_AST1(aggr));
  1112.             nam_node = N_AST2(aggr);
  1113.             make_index_node(nam_node, obj_node, subscript_list, comp_type);
  1114.             ncode = tup_add(code, N_LIST(stat_node));
  1115.             tup_free(code);
  1116.             code = ncode;
  1117.             code = tup_with(code, (char *)  new_expanded_node(dyn_node));
  1118.         }
  1119.  
  1120.         /*   Static component and indices. Special assignment format.  */
  1121.  
  1122.         else if (optable && static_index
  1123.           && (nk == as_string_ivalue || nk == as_ivalue
  1124.           ||  nk == as_int_literal   || nk == as_real_literal )) {
  1125.             static_node = new_node(as_static_comp);
  1126.             N_AST1(static_node) =
  1127.               new_index_node(obj_node, subscript_list, comp_type);
  1128.             N_AST2(static_node) = aggr;
  1129.             N_TYPE(static_node) = comp_type;
  1130.             code = tup_with(code, (char *) static_node); 
  1131.         } 
  1132.  
  1133.         /* Non-static case. Note that must initialize on some cases   */
  1134.  
  1135.         else {
  1136.             lhs  = new_index_node(obj_node, subscript_list, comp_type);
  1137.             p = INIT_PROC(base_type(comp_type));
  1138.             if (is_record_type(comp_type) && p != (Symbol)0) {
  1139.                 init_node = build_init_call(lhs, p, comp_type, obj_node);
  1140.                 code = tup_with(code, (char *) init_node);
  1141.             }
  1142.             code = tup_with(code, (char *)
  1143.             new_assign_node(lhs, new_expanded_node(aggr)));
  1144.         }
  1145.         return code;
  1146.     }
  1147.  
  1148.     /*
  1149.      * CASE 2:   Non-component level
  1150.      *   We are not at the last level of indexing and have more dimensions
  1151.      *   to process
  1152.      */
  1153.     code = tup_new(0);
  1154.     index_type_list = tup_copy(index_type_list_arg); 
  1155.     index_t = (Symbol) tup_fromb(index_type_list);
  1156.     pos_node = N_AST1(N_AST1(aggr));
  1157.     nam_node = N_AST2(N_AST1(aggr));
  1158.     others_node = N_AST2(aggr);
  1159.     pos = N_LIST(pos_node);
  1160.     nam = N_LIST(nam_node);
  1161.     N_SIDE(aggr) = FALSE;    /* Just an assumption */
  1162.  
  1163.     /*
  1164.      * STEP 1    
  1165.      *    Process the associations.  This consists on three subcases:
  1166.      *      1.  Positional associations
  1167.      *      2.  A single named association
  1168.      *      3.  Named associtions
  1169.      *    Note that in all cases there is room for possible optimizations
  1170.      */
  1171.  
  1172.     if (tup_size(pos) != 0) {
  1173.         /*
  1174.          *  SubCase 1:  positional part 
  1175.          */
  1176.  
  1177.          /*
  1178.           * STEP 1
  1179.           *    Find the lower bound of the aggregate and create a subscript node
  1180.           */
  1181.         tup = SIGNATURE(index_t);
  1182.         low = (Node) tup[2];
  1183.         high = (Node) tup[3];
  1184.         lw = get_ivalue(low);
  1185.         if (lw->const_kind != CONST_OM) {
  1186.             subscript = low;
  1187.             lw_int = get_ivalue_int(low);
  1188.             index = lw_int;
  1189.         }
  1190.         else {
  1191.             /* dynamic expression for lower bound. */
  1192.             low_node = new_attribute_node(ATTR_T_FIRST, new_name_node(index_t),
  1193.               OPT_NODE, index_t);
  1194.             subscript = low_node;
  1195.             index       = 0;
  1196.         }
  1197.  
  1198.          /*
  1199.           * STEP 2
  1200.           *    Process the positional associations 
  1201.           */
  1202.  
  1203.         FORTUP(v_expr = (Node), pos, ft1);
  1204.             stup = tup_copy(subscript_list);
  1205.             stup = tup_with(stup, (char *) subscript);
  1206.             ncode = tup_add(code, aggr_eval(v_expr, index_type_list, stup,
  1207.               obj_node, comp_type, optable));
  1208.             tup_free(code); code = ncode;
  1209.             N_SIDE(aggr) |= N_SIDE(v_expr);
  1210.  
  1211.             index += 1;
  1212.             if (lw->const_kind != CONST_OM) 
  1213.                 subscript = new_ivalue_node(int_const(index), index_t);
  1214.             else
  1215.                 subscript = new_binop_node(symbol_addi, low_node,
  1216.                   new_ivalue_node(int_const(index), index_t), index_t);
  1217.         ENDFORTUP(ft1);
  1218.  
  1219.          /*
  1220.           * STEP 3
  1221.           *  Process an others node if exists concurrent the positional assocs 
  1222.           */
  1223.  
  1224.         if ((others_node != OPT_NODE) && optable) {
  1225.             /* If it is optimization, then loop over the remaining indices and
  1226.              * create  the additional associations at this time.
  1227.              */ 
  1228.             hg_int = get_ivalue_int(high);
  1229.             pos = tup_exp(pos, (hg_int - lw_int) + 1);
  1230.             v_expr = others_node;
  1231.             for (i = index; i <= (hg_int); i++) {
  1232.                 stup = tup_copy(subscript_list);
  1233.                 stup = tup_with(stup, (char *) subscript);
  1234.                 v_expr_save = copy_tree((Node) v_expr);
  1235.                 ncode = tup_add(code, aggr_eval(v_expr, index_type_list,
  1236.                   stup, obj_node, comp_type, optable));
  1237.                 tup_free(code); code = ncode;
  1238.                 v_expr = v_expr_save;
  1239.                 subscript = new_ivalue_node(int_const(i + 1), index_t);
  1240.                 pos[(i - lw_int) + 1] = (char *) v_expr; 
  1241.                 if (i == hg_int) break;
  1242.             }
  1243.             N_SIDE(aggr) |= N_SIDE(others_node);
  1244.         }   /* end of optimized others node */
  1245.     
  1246.         else if (others_node != OPT_NODE) {
  1247.  
  1248.             /*  If it is not optimization, then create a run-time loop over the
  1249.              * remaining index positions
  1250.              */
  1251.  
  1252.             hg = new_index_bound_node(get_ivalue(high), ATTR_T_LAST, index_t);
  1253.             loop_var       = new_unique_name("index");
  1254.             TYPE_OF(loop_var) = index_t;
  1255.             loop_var_node       = new_name_node(loop_var);
  1256.             stup = tup_copy(subscript_list);
  1257.             stup = tup_with(stup, (char *)loop_var_node);
  1258.             expr_list = aggr_eval(others_node, index_type_list, stup, obj_node,
  1259.               comp_type, optable);
  1260.             N_SIDE(aggr) |= N_SIDE(others_node);
  1261.  
  1262.             loop_range = new_unique_name("range");
  1263.             tup = constraint_new(co_range);
  1264.             tup[2] = (char *) subscript;
  1265.             tup[3] = (char *) hg;
  1266.             new_symbol(loop_range, na_subtype, index_t, tup, (Symbol)0);
  1267.             range_node        = new_node(as_range);
  1268.             N_AST1(range_node) = subscript;
  1269.             N_AST2(range_node) = hg;
  1270.             iter            = new_node(as_subtype);
  1271.             N_AST1(iter)        = new_name_node(loop_range);
  1272.             N_AST2(iter)        = range_node;
  1273.             N_TYPE(iter)        = index_t;
  1274.             iter_node        = new_node(as_for);
  1275.             N_AST1(iter_node)  = loop_var_node;
  1276.             N_AST2(iter_node)  = iter;
  1277.             code  = tup_with(code, (char *) new_loop_node(OPT_NODE, iter_node,
  1278.               expr_list));
  1279.         }
  1280.     }
  1281.  
  1282.     else if (tup_size(nam) == 1 && tup_size(N_LIST(N_AST1((Node) nam[1]))) == 1
  1283.       && others_node == OPT_NODE ) {
  1284.  
  1285.         /*
  1286.          * CASE 2: Single named assoiation
  1287.          */
  1288.         /*  If all is optable, loop over the indices and create entries for a
  1289.          *  data segment at this time changing it into a positional association
  1290.          */
  1291.  
  1292.         if (optable) {
  1293.             tup = SIGNATURE(index_t);
  1294.             low = (Node) tup[2];
  1295.             high = (Node) tup[3];
  1296.             lw_int = get_ivalue_int(low);
  1297.             hg_int = get_ivalue_int(high);
  1298.             pos = tup_new(hg_int + 1 - lw_int);
  1299.             assoc = (Node) nam[1];
  1300.             v_expr = N_AST2(assoc);
  1301.             for (i = lw_int; i <= (hg_int); i++) {
  1302.                 subscript = new_ivalue_node(int_const(i), index_t);
  1303.                 stup = tup_copy(subscript_list);
  1304.                 stup = tup_with(stup, (char *) subscript);
  1305.                 v_expr_save = copy_tree((Node) v_expr);
  1306.                 comp_list = aggr_eval(v_expr, index_type_list,
  1307.                   stup, obj_node, comp_type, optable);
  1308.                 v_expr = v_expr_save;
  1309.                 ncode = tup_add(code, comp_list);
  1310.                 tup_free(code); code = ncode;
  1311.                 pos[(i - lw_int) + 1] = (char *) v_expr; 
  1312.                 if (i == hg_int) break;
  1313.             }
  1314.  
  1315.             N_SIDE(aggr) = N_SIDE(v_expr);
  1316.             N_LIST(nam_node) = tup_new(0);
  1317.             N_LIST(pos_node) = pos;
  1318.         }   /* end of optimized others node */
  1319.     
  1320.         else {
  1321.             /*   if non-optable then create a run_time loop over the indices */
  1322.  
  1323.             assoc = (Node) nam[1];
  1324.             choice_list_node = N_AST1(assoc);
  1325.             v_expr = N_AST2(assoc);
  1326.             tup = N_LIST(choice_list_node);
  1327.             range_node = (Node) tup[1];
  1328.             if (N_KIND(range_node) == as_simple_choice) {
  1329.                 stup = tup_copy(subscript_list);
  1330.                 stup = tup_with(stup, (char *) N_AST1(range_node));
  1331.                 comp_list = aggr_eval(v_expr, index_type_list, stup, obj_node,
  1332.                   comp_type, optable);
  1333.                 N_SIDE(aggr) = N_SIDE(v_expr);
  1334.                 ncode = tup_add(code, comp_list);
  1335.                 tup_free(code); code = ncode;
  1336.             }
  1337.             else {
  1338.                 loop_var      = new_unique_name("index_t");
  1339.                 TYPE_OF(loop_var)= index_t;
  1340.                 loop_var_node      = new_name_node(loop_var);
  1341.                 stup = tup_copy(subscript_list);
  1342.                 stup = tup_with(stup, (char *) loop_var_node);
  1343.                 comp_list  = aggr_eval(v_expr, index_type_list, stup, obj_node,
  1344.                   comp_type, optable);
  1345.                 N_SIDE(aggr) |= N_SIDE(v_expr);
  1346.                 body_node    = new_statements_node(comp_list);
  1347.  
  1348.                 /* Finally we build a loop over the choice range, whose body */
  1349.                 /* is the initialisation of the sub aggregate */
  1350.                 var_node        = new_name_node(loop_var);
  1351.                 iter_node        = new_node(as_for);
  1352.                 N_TYPE(range_node) = index_t;
  1353.                 N_AST1(iter_node)   = var_node;
  1354.                 N_AST2(iter_node)   = range_node;
  1355.                 code = tup_with(code, (char *) new_loop_node(OPT_NODE,
  1356.                   iter_node, tup_new1((char *) body_node)));
  1357.             }
  1358.         }
  1359.     }  /* of a single named association   */
  1360.  
  1361.     /*
  1362.      *  CASE 3:  Named Association
  1363.      */
  1364.  
  1365.     else if (optable) {
  1366.         /*  If the aggregate is optable, then change each choice
  1367.          *  into a series on positional association.  If there is an others
  1368.          *  clause then use this to 'fill-in' any missing associations
  1369.          */ 
  1370.         tup = SIGNATURE(index_t);
  1371.         lbd_node = (Node) tup[2];
  1372.         ubd_node = (Node) tup[3];
  1373.         lbd_index_t = get_ivalue_int(lbd_node);
  1374.         ubd_index_t = get_ivalue_int(ubd_node);
  1375.         pos = tup_new(ubd_index_t - lbd_index_t + 1);
  1376.         for (i = 1; i <= tup_size(pos); i++)
  1377.             pos[i] = (char *) 0; 
  1378.  
  1379.         FORTUP(assoc = (Node), nam, ft1);
  1380.             choice_list_node = N_AST1(assoc);
  1381.             v_expr = N_AST2(assoc);
  1382.             FORTUP(choice = (Node), N_LIST(choice_list_node), ft2);
  1383.                 nk = N_KIND(choice);
  1384.                 if (nk == as_simple_name) {
  1385.                     temp = N_UNQ(choice);
  1386.                     tup = SIGNATURE(temp);
  1387.                     lbd_node = (Node) tup[2];
  1388.                     ubd_node = (Node) tup[3];
  1389.                     lw_val = get_ivalue_int(lbd_node);
  1390.                     hg_val = get_ivalue_int(ubd_node);
  1391.                 }
  1392.                 else if (nk == as_range) {
  1393.                     /* We know from previous pass that it is static. */
  1394.                     lbd_node = N_AST1(choice);
  1395.                     ubd_node = N_AST2(choice);
  1396.                     lw_val = get_ivalue_int(lbd_node);
  1397.                     hg_val = get_ivalue_int(ubd_node);
  1398.                 }
  1399.                 else if(nk == as_simple_choice) {
  1400.                     lbd_node = N_AST1(choice);
  1401.                     lw_val = get_ivalue_int(lbd_node);
  1402.                     hg_val = lw_val;
  1403.                 }
  1404.                 else if (nk == as_ivalue || nk == as_int_literal) {
  1405.                     lw_val = get_ivalue_int(choice);
  1406.                     hg_val = lw_val;
  1407.                 }
  1408.                 else {
  1409.                     compiler_error_k("Unknown choice in aggr_type: ", choice);
  1410.                 }
  1411.  
  1412.                 for (i = lw_val; i <= hg_val; i++) {
  1413.                     subscript = new_ivalue_node(int_const(i), index_t);
  1414.                     stup = tup_copy(subscript_list);
  1415.                     stup = tup_with(stup, (char *) subscript);
  1416.                     v_expr_save = copy_tree((Node) v_expr);
  1417.                     ncode = tup_add(code, aggr_eval(v_expr, index_type_list,
  1418.                       stup, obj_node, comp_type, optable));
  1419.                     tup_free(code); code = ncode;
  1420.                     v_expr = v_expr_save;
  1421.                     pos[(i - lbd_index_t) + 1] = (char *) v_expr;
  1422.                     if (i == hg_val) break;
  1423.                 }
  1424.             ENDFORTUP(ft2);
  1425.             N_SIDE(aggr)  |= N_SIDE(v_expr);
  1426.         ENDFORTUP(ft1);
  1427.  
  1428.         if (others_node != OPT_NODE) {
  1429.             v_expr = others_node;
  1430.             for (i = 1; i <= (tup_size(pos)); i++) {
  1431.                 if (pos[i] == (char *) 0) {
  1432.                     subscript = new_ivalue_node(int_const((lbd_index_t + i)-1),
  1433.                       index_t);
  1434.                     stup = tup_copy(subscript_list);
  1435.                     stup = tup_with(stup, (char *) subscript);
  1436.                     v_expr_save = copy_tree((Node) v_expr);
  1437.                     ncode = tup_add(code, aggr_eval(v_expr, index_type_list,
  1438.                       stup, obj_node, comp_type, optable));
  1439.                     tup_free(code); code = ncode;
  1440.                     v_expr = v_expr_save;
  1441.                 }
  1442.             }
  1443.             N_SIDE(aggr)     |= N_SIDE(others_node);
  1444.         }
  1445.     
  1446.         N_LIST(nam_node) = tup_new(0);
  1447.         N_LIST(pos_node) = pos;
  1448.     }
  1449.  
  1450.     else {   /* array is too big to expand at compile time  */
  1451.         /*
  1452.          *     If the aggregate is not optimizable then
  1453.          *     the code emitted is a run-time case statement  within 
  1454.          *     a loop with variable which ranges over the index type.
  1455.          */
  1456.  
  1457.         loop_var        = new_unique_name("index_t");
  1458.         TYPE_OF(loop_var)= index_t;
  1459.         loop_var_node    = new_name_node(loop_var);
  1460.         case_list        = tup_new(0);
  1461.  
  1462.         FORTUP(assoc = (Node), nam, ft1);
  1463.             choice_list_node = N_AST1(assoc);
  1464.             v_expr = N_AST2(assoc);
  1465.             stup = tup_copy(subscript_list);
  1466.             stup = tup_with(stup, (char *) loop_var_node);
  1467.             comp_list = aggr_eval(v_expr, index_type_list, stup, obj_node,
  1468.               comp_type, optable);
  1469.             N_SIDE(aggr)  |= N_SIDE(v_expr);
  1470.             new_case     = new_node(as_case_statements);
  1471.             N_AST1(new_case) = choice_list_node;
  1472.             N_AST2(new_case) = new_statements_node(comp_list);
  1473.             case_list  = tup_with(case_list, (char *) new_case);
  1474.         ENDFORTUP(ft1);
  1475.  
  1476.         if (others_node != OPT_NODE) {
  1477.             stup = tup_copy(subscript_list);
  1478.             stup = tup_with(stup, (char *) loop_var_node);
  1479.             comp_list   = aggr_eval(others_node, index_type_list, stup,
  1480.               obj_node, comp_type, optable);
  1481.             N_SIDE(aggr)     |= N_SIDE(others_node);
  1482.             list_node       = new_node(as_list);
  1483.             N_LIST(list_node) = tup_new1((char *) new_node(as_others_choice));
  1484.             new_case       = new_node(as_case_statements);
  1485.             N_AST1(new_case)   = list_node;
  1486.             N_AST2(new_case)   = new_statements_node(comp_list);
  1487.             case_list     = tup_with(case_list, (char *) new_case);
  1488.         }
  1489.  
  1490.         cases        = new_node(as_list);
  1491.         N_LIST(cases)    = case_list;
  1492.         case_body        = new_node(as_case);
  1493.         case_expr        = new_name_node(loop_var);
  1494.         N_AST1(case_body) = case_expr;
  1495.         N_AST2(case_body) = cases;
  1496.  
  1497.         /* Finally we build a loop over the index range, whose body is */
  1498.         /* the case statement assigning to various components. */
  1499.         var_node        = new_name_node(loop_var);
  1500.         iter_node        = new_node(as_for);
  1501.         N_AST1(iter_node) = var_node;
  1502.         N_AST2(iter_node) = new_name_node(index_t);
  1503.         code = tup_with(code, (char *) new_loop_node(OPT_NODE, iter_node, 
  1504.           tup_new1((char *) case_body)));
  1505.     }
  1506.     return code;
  1507. }
  1508.  
  1509. static Node new_index_bound_node(Const v, int attribute, Symbol type_name)
  1510.                                                     /*;new_index_bound_node*/
  1511. {
  1512.     Node    node;
  1513.  
  1514.     if (v->const_kind != CONST_OM) 
  1515.         node = new_ivalue_node(v, type_name);
  1516.     else
  1517.         node = new_attribute_node(attribute, new_name_node(type_name),
  1518.           new_ivalue_node(int_const(1), symbol_integer), type_name);
  1519.     return node;
  1520. }
  1521.  
  1522. void expand_record_aggregate(Node node)            /*;expand_record_aggregate*/
  1523. {
  1524.     /*
  1525.      * Normalize the format of a record aggregate. The component associations
  1526.      * are separated into a list of static components, and a list of indivi-
  1527.      * dual assignments to selected components of the object.
  1528.      * A dummy name node is emitted, which is eventually bound to the entity
  1529.      * that receives the aggregate.
  1530.      */
  1531.  
  1532.     Symbol    type_name, some_discr, discr_name, subtype, obj_name;
  1533.     Symbol    comp_type, p, field_name;
  1534.     Tuple    comp_list, d_l, field_list, dyn_list, tup, ntup, discr_map;
  1535.     Node    comp_assoc, lhs;
  1536.     int        i, static_check, mismat_disc_err;
  1537.     Fortup    ft1, ft2;
  1538.     Node    e_node, n_node, static_comps, obj_node, stat_node, dyn_node;
  1539.     Node    aggr_node, nam_node, init_node, n, n_d, stmts_node, d_node, lnode;
  1540.     Symbol      index, c_t, a_t, field_type;
  1541.     Tuple    new_decls;
  1542.     int      qualified;
  1543.  
  1544. #ifdef TRACE
  1545.     if (debug_flag)
  1546.         gen_trace_node("RECORD_AGGREGATE", node);
  1547. #endif
  1548.     /*
  1549.      * STEP 1:
  1550.      *    Initialize variables
  1551.      */
  1552.     type_name = N_TYPE(node);
  1553.     comp_list = N_LIST(N_AST1(N_AST1(node)));
  1554.     new_decls = tup_new(0);
  1555.     field_list= tup_new(0);
  1556.     subtype   = type_name;
  1557.     /*
  1558.      * STEP 2 
  1559.      *     Collect discriminants to emit constrained array  subtypes for
  1560.      *     components that may depend on discriminants. If type is unconstrained
  1561.      *     the object takes its constraints from the aggregate itself and a
  1562.      *     subtype is created for it here.
  1563.      */
  1564.     if (has_discriminant(type_name)) {
  1565.         d_l = discriminant_list_get(type_name);
  1566.         some_discr = (Symbol)d_l[2];
  1567.         if (is_unconstrained(type_name)
  1568.           && (Node)default_expr(some_discr) == OPT_NODE) { 
  1569.             subtype= new_unique_name("agg_type");
  1570.         }
  1571.         for (i = 1; i <= tup_size(d_l); i++) {
  1572.             comp_assoc         = (Node) comp_list[i];
  1573.             n_node = N_AST1(comp_assoc);
  1574.             e_node = N_AST2(comp_assoc);
  1575.             discr_name         = N_UNQ(n_node);
  1576.             expand(e_node);
  1577.             field_list = discr_map_put(field_list,discr_name,copy_node(e_node));
  1578. #ifdef TBSN
  1579.             if (!is_ivalue(e_node)) {
  1580.                 /* this should be done when building the object and not the
  1581.                  * subtype value need not be static if there is no variant part
  1582.                  */
  1583.                 make_discr_ref_node(e_node, discr_name, subtype);
  1584.             }
  1585. #endif
  1586.         } /* end loop */
  1587.     }
  1588.  
  1589.     /* 
  1590.      * STEP 3
  1591.      *    If the subtype is not a type_name then build a symbol table entry
  1592.      */
  1593.     if (subtype != type_name) {    
  1594.         NATURE (subtype) = na_subtype;
  1595.         TYPE_OF(subtype) = base_type(type_name);
  1596.         tup = constraint_new(co_discr);
  1597.         tup[2] = (char *) field_list;
  1598.         SIGNATURE(subtype) = tup;
  1599.         ALIAS      (subtype) = ALIAS(type_name);
  1600.         CONTAINS_TASK(subtype) = CONTAINS_TASK(type_name);
  1601.         type_name        = subtype;
  1602.         N_TYPE(node)        = type_name;
  1603.         new_decls = (Tuple)tup_new1((char *)new_subtype_decl_node(type_name));
  1604.     }
  1605.  
  1606.     mismat_disc_err = FALSE;
  1607.     static_check  = TRUE;
  1608.     /* 
  1609.      * STEP 4
  1610.      *    If it is constrained an has a discriminant then check the discriminant
  1611.      *    against the expected subtype
  1612.      */
  1613.     if (has_discriminant(type_name) && (!is_unconstrained(type_name)) ) {
  1614.         tup = SIGNATURE(type_name);
  1615.         discr_map = (Tuple) tup[2];
  1616.         for (i = 1; i <= tup_size(d_l); i++) {
  1617.             comp_assoc      = (Node) comp_list[i];
  1618.             n_node = N_AST1(comp_assoc);
  1619.             e_node = N_AST2(comp_assoc);
  1620.             discr_name      = N_UNQ(n_node);
  1621.             d_node          = discr_map_get(discr_map, discr_name);
  1622.             if (is_ivalue(e_node) && is_ivalue(d_node)) {
  1623.                 if (INTV(get_ivalue(e_node)) != INTV(get_ivalue(d_node))) {
  1624.                     mismat_disc_err = TRUE;
  1625.                     break;
  1626.                 }
  1627.             }
  1628.             else {
  1629.                 static_check = FALSE;
  1630.                 break;
  1631.             }
  1632.         }
  1633.     }
  1634.  
  1635.     /*
  1636.      * STEP 6
  1637.      *    process each of the components of the record aggregate
  1638.      */
  1639.     static_comps        = new_node(as_list);
  1640.     N_LIST(static_comps) = tup_new(0);
  1641.     dyn_list        = tup_new(0);
  1642.     obj_name        = N_UNQ(node);
  1643.     obj_node        = new_name_node(obj_name);
  1644.     new_symbol(obj_name, na_obj, N_TYPE(node), (Tuple)0, (Symbol)0);
  1645.  
  1646.     FORTUP(comp_assoc = (Node), comp_list, ft1);
  1647.         n_node = N_AST1(comp_assoc);
  1648.         e_node = N_AST2(comp_assoc);
  1649.         field_name = N_UNQ(n_node);
  1650.         comp_type  = TYPE_OF(field_name);
  1651.  
  1652.         field_type = N_TYPE(e_node); 
  1653.         if (field_type != comp_type) {
  1654.             /* the front-end recomputes the subtypes of components that
  1655.              * depend on discriminants, using the values for these that
  1656.              * appear in the aggregate itself. emit declarations for these
  1657.              * subtypes in front of the aggregate.
  1658.              */
  1659.             if (is_access(field_type))   {
  1660.                 a_t = (Symbol)designated_type(field_type);
  1661.                 c_t = (Symbol)designated_type(comp_type);
  1662.             }
  1663.             else  {
  1664.                 a_t = field_type;
  1665.                 c_t = comp_type;
  1666.             }
  1667.             if (is_array(a_t)) {
  1668.                 FORTUPI(index = (Symbol), index_types(a_t), i, ft2)
  1669.                     if (index_types(c_t)[i] != (char *)index) {
  1670.                         new_decls = tup_with(new_decls,
  1671.                           (char *)new_subtype_decl_node(index));
  1672.                     }
  1673.                 ENDFORTUP(ft2);
  1674.             }
  1675.             else {
  1676.                 /* TBSL: record, and access to record, components.*/
  1677.                 ;
  1678.             }
  1679.             n_d = new_subtype_decl_node(a_t);
  1680.             expand(n_d);
  1681.             new_decls = tup_with(new_decls, (char *)n_d);
  1682.  
  1683.             if (is_access(field_type)) {
  1684.                 n_d = new_subtype_decl_node(field_type);
  1685.                 new_decls = tup_with(new_decls, (char *)n_d);
  1686.             }
  1687.             N_TYPE(e_node) = field_type;
  1688.         }
  1689.  
  1690.         if (is_array_type(comp_type)) {
  1691.             expand(e_node);
  1692.             if (N_KIND(e_node) == as_qual_index) {
  1693.                 qualified = TRUE;
  1694.                 aggr_node = N_AST1(e_node);
  1695.             }
  1696.             else {
  1697.                 qualified = FALSE;
  1698.                 aggr_node = e_node;
  1699.             }
  1700.  
  1701.             if (N_KIND(aggr_node) == as_insert) {
  1702.                 /* emit anonymous subtypes in front, and get aggregate */
  1703.                 ntup = tup_add(new_decls, N_LIST(aggr_node));
  1704.                 tup_free(new_decls);
  1705.                 new_decls = ntup;
  1706.                 aggr_node = N_AST1(aggr_node);
  1707.             }
  1708.  
  1709.             if (is_ivalue(aggr_node)
  1710.               && (N_KIND(aggr_node) != as_array_ivalue && !qualified)) {
  1711.                 lhs = new_selector_node(obj_node, field_name);
  1712.                 N_KIND(comp_assoc)         = as_static_comp;
  1713.                 N_AST1(comp_assoc)         = lhs;
  1714.                 N_LIST(comp_assoc)         = (Tuple)0;
  1715.                 N_AST2(comp_assoc)         = aggr_node;
  1716.                 tup = N_LIST(static_comps);
  1717.                 tup = tup_with(tup, (char *) comp_assoc);
  1718.                 N_LIST(static_comps) = tup;
  1719.             }
  1720.             else if (is_aggregate(aggr_node) && !qualified) {
  1721.                 stat_node = N_AST1(N_AST1(aggr_node));
  1722.                 dyn_node  = N_AST2(N_AST1(aggr_node));
  1723.                 nam_node  = N_AST2(aggr_node);
  1724.                 make_selector_node(nam_node, obj_node, field_name);
  1725.                 ntup = tup_add(N_LIST(static_comps), N_LIST(stat_node));
  1726.                 tup_free(N_LIST(static_comps)); N_LIST(static_comps) = ntup;
  1727.                 dyn_list = tup_with(dyn_list, (char *) dyn_node);
  1728.             }
  1729.             else {            /* variable, possibly with constraints */
  1730.                 lhs = new_selector_node(obj_node, field_name);
  1731.                 n = new_assign_node(lhs, e_node);
  1732.                 dyn_list = tup_with(dyn_list, (char *) n);
  1733.             }
  1734.         }
  1735.         else { /* Discriminants were expanded above. */
  1736.             if (NATURE(field_name) != na_discriminant)
  1737.                 expand(e_node);
  1738.             /* Emit an assigment to a selected component of the object. */
  1739.             if (is_aggregate(e_node)) {
  1740.                 stat_node = N_AST1(N_AST1(e_node));
  1741.                 dyn_node  = N_AST2(N_AST1(e_node));
  1742.                 nam_node  = N_AST2(e_node);
  1743.                 make_selector_node(nam_node, obj_node, field_name);
  1744.                 ntup = tup_add(N_LIST(static_comps), N_LIST(stat_node));
  1745.                 tup_free(N_LIST(static_comps));
  1746.                 N_LIST(static_comps) = ntup;
  1747.                 dyn_list = tup_with(dyn_list, (char *) dyn_node);
  1748.             }
  1749.             else  {
  1750.                 lhs = new_selector_node(obj_node, field_name);
  1751.                 if (is_ivalue(e_node)) {
  1752.                     N_KIND(comp_assoc)         = as_static_comp;
  1753.                     N_AST1(comp_assoc)         = lhs;
  1754.                     N_LIST(comp_assoc)         = (Tuple)0;
  1755.                     N_AST2(comp_assoc)         = e_node;
  1756.                     tup = N_LIST(static_comps);
  1757.                     tup = tup_with(tup, (char *) comp_assoc);
  1758.                     N_LIST(static_comps) = tup;
  1759.                 }
  1760.                 else {
  1761.                     p = INIT_PROC((Symbol) base_type(comp_type));
  1762.                     if (is_record_type(comp_type) && p != (Symbol)0) {
  1763.                           /* Assignment cannot be performed unless lhs */
  1764.                           /* correctly initialized. */
  1765.                           init_node = build_init_call(lhs, p, comp_type,obj_node);
  1766.                           dyn_list = tup_with(dyn_list, (char *)  init_node);
  1767.                     }
  1768.                     n = new_assign_node(lhs, e_node);
  1769.                     dyn_list = tup_with(dyn_list, (char *) n);
  1770.                 }
  1771.             }
  1772.         } /*end*/
  1773.     ENDFORTUP(ft1);
  1774.  
  1775.     if (tup_size(dyn_list) == 0 && !qualified) { /* fully static aggregate. */
  1776.         N_KIND(node) = as_record_ivalue;
  1777.         lnode = node_new(as_aggregate_list);
  1778.         N_AST1(lnode) = static_comps;
  1779.         N_AST2(lnode) = OPT_NODE;
  1780.         N_AST1(node) = lnode;
  1781.         N_AST2(node) = obj_node;
  1782.     }
  1783.     else {
  1784.         stmts_node   = new_statements_node(dyn_list);
  1785.         if (!is_aggregate(node)) { /* this check may be redundant DS */
  1786.             printf("aggr dyn_list kind %d\n", N_KIND(node)); /*DEBUG DS */
  1787.             chaos("aggr - not aggregate node");
  1788.         }
  1789.         lnode = node_new(as_aggregate_list);
  1790.         N_AST1(lnode) = static_comps;
  1791.         N_AST2(lnode) = stmts_node;
  1792.         N_AST1(node) = lnode;
  1793.         N_AST2(node) = obj_node;
  1794.     }
  1795.  
  1796.     if (!static_check) { /* Add qual_discr */
  1797.         subtype      = N_TYPE(node);
  1798.         N_AST4(node) = (Node)0;
  1799.         N_TYPE(node) = base_type(type_name);    /* Only thing we know... */
  1800.         N_AST1(node) = copy_node(node);
  1801.         N_AST2(node) = N_AST3(node) = (Node) 0;
  1802.         N_KIND(node) = as_qual_discr;
  1803.         N_TYPE(node) = subtype;
  1804.     }
  1805.     else if (mismat_disc_err) {  
  1806.         /* make_insert_node needs to be done here, at the end of the
  1807.          * expansion, while the test needs to be done at the beginning.
  1808.          * This is when the discriminant announced does not match with
  1809.          * the one in the aggregate.
  1810.          */
  1811.         make_insert_node(node, (Tuple) tup_new1((char *) new_raise_node(
  1812.           symbol_constraint_error)), copy_node(node));
  1813.         USER_WARNING("Mismatched discriminants will raise"," CONSTRAINT_ERROR");
  1814.     }
  1815.  
  1816.     if (tup_size(new_decls) != 0) {
  1817.         /* add declarations of constrained array types in front */
  1818.         make_insert_node(node, new_decls, copy_node(node));
  1819.     }
  1820. }
  1821.